home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
dbf4pas.zip
/
DEMO4.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-01-04
|
5KB
|
169 lines
{ This is a short demo of the DBF unit. I didn't have time to make this }
{ readable. So you can see what I had to go through with this guy's code! }
program DBF_Demo;
uses crt,dbf;
var
d : dbfrecord;
PROCEDURE ErrorHalt(errorCode : Integer);
VAR
errorMsg : _Str80;
BEGIN
CASE errorCode OF
00 : Exit; { no error occurred }
$01 : errorMsg := 'Not found';
$02 : errorMsg := 'Not open for input';
$03 : errorMsg := 'Not open for output';
$04 : errorMsg := 'Just not open';
$91 : errorMsg := 'Seek beyond EOF';
$99 : errorMsg := 'Unexpected EOF';
$F0 : errorMsg := 'Disk write error';
$F1 : errorMsg := 'Directory full';
$F3 : errorMsg := 'Too many files';
$FF : errorMsg := 'Where did that file go?';
NOT_DB_FILE : errorMsg := 'Not a dBASE data file';
INVALID_FIELD : errorMsg := 'Invalid field type encountered';
REC_TOO_HIGH : errorMsg := 'Requested record beyond range';
PARTIAL_READ : errorMsg := 'Tried to read beyon EOF';
ELSE
errorMsg := 'Undefined error';
END;
WriteLn;
WriteLn(errorCode:3, ': ',errorMsg);
Halt(1);
END;
TYPE
PseudoStr = ARRAY[1..255] OF Char;
VAR
Demo : dbfRecord;
j, i : Integer;
blanks : _Str255;
SizeOfFile, r : longint;
fn : _Str64;
PROCEDURE Wait;
VAR
c : Char;
BEGIN
Write('Press any key to continue . . .');
repeat
c := readkey
until c <> #0
END;
PROCEDURE List(VAR D : dbfRecord);
PROCEDURE ShowField(VAR a; VAR F : _FieldRecord);
VAR
Data : PseudoStr ABSOLUTE a;
BEGIN
WITH F DO
BEGIN
CASE Typ OF
'C', 'N', 'L' : Write(Copy(Data, 1, Len));
'M' : Write('Memo ');
'D' : Write(Copy(Data, 5, 2), '/',
Copy(Data, 7, 2), '/',
Copy(Data, 1, 2));
END; {CASE}
IF Len <= Length(Name) THEN
Write(Copy(blanks, 1, Length(Name)-Pred(Len)))
ELSE
Write(' ');
END; {WITH F}
END; {ShowField}
BEGIN {List}
WriteLn;
Write('Rec Num ');
WITH D DO
BEGIN
FOR i := 1 TO NumFields DO
WITH Fields^[i] DO
IF Len >= Length(Name) THEN
Write(Name, Copy(blanks, 1, Succ(Len-Length(Name))))
ELSE
Write(Name, ' ');
WriteLn;
r := 1;
WHILE r <= NumRecs DO
BEGIN
GetDbfRecord(Demo, r);
IF NOT dbfOK THEN ErrorHalt(dbfError);
WriteLn;
Write(r:7, ' ');
Write(Chr(CurRecord^[0])); { the 'deleted' indicator }
FOR i := 1 TO NumFields DO
ShowField(CurRecord^[Fields^[i].Off], Fields^[i]);
r := r+1;
END; {WHILE r }
END; {WITH D }
END; {List}
PROCEDURE DisplayStructure(VAR D : dbfRecord);
VAR
i : Integer;
BEGIN
WITH D DO
BEGIN
ClrScr;
Write(' # Field Name Type Length Decimal');
FOR i := 1 TO NumFields DO
BEGIN
WITH Fields^[i] DO
BEGIN
IF i MOD 20 = 0 THEN
BEGIN
WriteLn;
Wait;
ClrScr;
Write(' # Field Name Type Length Decimal');
END;
GoToXY(1, Succ(WhereY));
Write(i:2, Name:12, Typ:5, Len:9);
IF Typ = 'N' THEN Write(Dec:5);
END; {WITH Fields^}
END; {FOR}
WriteLn;
Wait;
END; {WITH D}
END; { DisplayStructure }
BEGIN
WITH Demo DO
BEGIN
FillChar(blanks, SizeOf(blanks), $20);
blanks[0] := Chr(255);
ClrScr;
GoToXY(10, 10);
Write('Name of dBASE file (.DBF assumed): ');
Read(FileName);
IF Pos('.', FileName) = 0 THEN FileName := FileName+'.DBF';
OpenDbf(Demo);
IF NOT dbfOK THEN ErrorHalt(dbfError);
ClrScr;
SizeOfFile := FileSize(dFile);
WriteLn('File Name: ', FileName);
WriteLn('Date Of Last Update: ', DateOfUpdate);
WriteLn('Number of Records: ', NumRecs:10);
WriteLn('Size of File: ', SizeOfFile:15);
WriteLn('Length of Header: ', HeadLen:11);
WriteLn('Length of One Record: ', RecLen:7);
IF WithMemo THEN WriteLn('This file contains Memo fields.');
IF HeadProlog[0] = DB2File THEN WriteLn('dBASE 2.4 file');
Wait;
ClrScr;
DisplayStructure(Demo);
ClrScr;
List(Demo);
WriteLn;
Wait;
CloseDbf(Demo);
IF NOT dbfOK THEN ErrorHalt(dbfError);
END;
END.